Transactor/Transactor_20_1987_Transactor_Publishing.d64/common code.pal

Commodore BASIC | 2023-02-26 | 11KB | 415 lines

1000 rem save"0:common code.pal",8
1010 open 8,8,8,"0:common code,p,w
1020 [158]700
1030 .opt o8
1040 ; [172] comm[145] code by jack r. farrah
1050 ;program [164] find identical code sequences
1060 ;in machine language programs [129] use
1070 ;as [185]sible subroutines.
1080 ;tested program [164] be in mem[176]y.
1090 ;all user [133]s in hex.
1100 ;screen [176] [153]er output.
1110 ;space bar pauses [155]ing.
1120 ; [172] c[145]s[192]ts [172]
1130 chrin [178] $ffcf ;[161] mult. char.[133]
1140 chrout [178] $ffd2 ;[153] [164] device
1150 [161]in [178] $ffe4 ;[161] [191]gle char.
1160 stadd [178] $fb ;start address
1170 ckadd [178] $fd ;check address
1180 setlfs [178] $ffba ;set [188]. file
1190 setnam [178] $ffbd ;name file
1200 [159] [178] $ffc0 ;[159] file
1210 [160] [178] $ffc3 ;[160] file
1220 chkout [178] $ffc9 ;set output file
1230 [156]chn [178] $ffcc ;[140] [150]aults
1240 [172][178]$0801 ;2049
1250 .w[176]d twobrk ;[129]ward po[181]er
1260 .byte 10,0 ;line number
1270 .byte $9e ;"sys" keyw[176]d [164]ken
1280 .[198] "2061" ;[158] address
1290 brk
1300 twobrk .w[176]d 0
1310 lda #147 ;clear screen
1320 jsr chrout
1330 begin ldx #0
1340 stx inflg ;clear flags
1350 stx mtchflg
1360 ;[172][161] user start address[172]
1370 titl lda title,x ;[153] prog. name
1380 beq start ;[175] start add.
1390 jsr chrout ;[133] message
1400 inx
1410 bne titl
1420 start ldx #0 ;set index
1430 jsr cr[145] ;blink curs[176]
1440 jsr [161] ;[161] address
1450 check cpx #5 ;">4 characters?
1460 bcs error ;only want 4
1470 ck1 dex  ;reset for cr counted
1480 cpx #255 ;only after 4
1490 beq convert ;make binary
1500 lda hxadd,x ;get hex ascii
1510 jsr eval ;check if valid
1520 bcc ck1 ;ok.get next char.
1530 ;*error message loop*
1540 error lda #$0d ;cr
1550 jsr chrout
1560 jsr crof ;turn off cursor
1570 ldx #0
1580 er1 lda ermess,x ;print error message
1590 beq begin ;start over
1600 jsr chrout
1610 inx
1620 bne er1
1630 ;*change ascii hex to binary & store
1640 convert ldx #0 ;set index
1650 jsr crof ;unblink cursor
1660 loop lda hxadd,x ;get ascii
1670 jsr makbi ;make binary
1680 asl  ;shift value into
1690 asl  ;high nybble position
1700 asl
1710 asl
1720 sta hxadd,x ;save it
1730 inx  ;raise index
1740 lda hxadd,x ;get next ascii
1750 jsr makbi ;make binary
1760 cpx #3 ;"4th character?
1770 beq over ;yes. finish here
1780 clc  ;no
1790 adc hxadd ;add [164] high nybble
1800 sta hxadd ;[148] combined [197]ue
1810 inx  ;raise index
1820 bne loop ;always branch
1830 over clc  ;add low nybble of
1840 adc hxadd[170]2 ;low byte [164] high
1850 sta hxadd[170]2 ;[175] [148] it
1860 [128] lda inflg ;"done end address?
1870 bne output ;yes.flag set
1880 lda hxadd ;no.save start add.
1890 sta stadd+1 ;on zero page
1900 lda hxadd+2
1910 sta stadd
1920 lda #$0d ;cr
1930 jsr chrout
1940 sta inflg ;set flag
1950 ;*get user end address*
1960 ldx #0 ;clear index
1970 end1 lda endmess,x ;print message
1980 beq next
1990 jsr chrout
2000 inx
2010 bne end1
2020 next ldx #0 ;clear for char. count
2030 jsr cron ;blink cursor
2040 jsr get ;get the address
2050 jmp check ;check &make binary
2060 output lda hxadd ;get binary end add.
2070 sta enck+1 ;and store in zero page
2080 lda hxadd+2
2090 sta enck
2100 lda #$0d ;cr
2110 jsr chrout
2120 ;*get output destination from user*
2130 ldx #0
2140 out1 lda outmess,x ;print message
2150 beq getit
2160 jsr chrout
2170 inx
2180 bne out1
2190 getit jsr getin ;get 's' or 'p'
2200 beq getit ;wait for key
2210 cmp #80 ;"p?
2220 beq [153] ;yes. [159] [153]er
2230 cmp #83 ;"no. s?
2240 bne getit ;no.(NULL) back for key
2250 beq byte ;screen output
2260 print jsr prout ;open printer file
2270 ;*get byte lgth. from user*
2280 byte ldx #0
2290 bytlup lda bytmess,x ;print message
2300 beq gtbyt
2310 jsr chrout
2320 inx
2330 bne bytlup
2340 erjmp jmp error ;out of range avoider
2350 gtbyt jsr cron ;blink cursor
2360 gt2 jsr getin ;get key
2370 beq gt2 ;wait for key
2380 cmp #$0d ;"cr?
2390 beq set[128] ;[150]ault selected
2400 jsr chrout ;[162] [197]ue. [153] it
2410 jsr e[197] ;check range
2420 jsr makbi ;make binary
2430 asl  ;sh[139]t [164] hi nybble
2440 asl
2450 asl
2460 asl
2470 sta hldr ;[148] it
2480 gt1 jsr [161]in ;[161] sec[145]d char.
2490 beq gt1 ;[146] [129] it
2500 jsr chrout ;[153] iit
2510 jsr e[197] ;check range
2520 jsr makbi ;make binary
2530 clc  ;add [164] hi nybble
2540 adc hldr
2550 cmp #2 ;">1?
2560 bcc erjmp ;<2 not allowed
2570 sta ckbyt ;store new value
2580 lda #$0d ;cr
2590 jsr chrout
2600 ;*calculate end addresses*
2610 setend jsr crof ;unblink cursor
2620 lda #$0d ;cr
2630 jsr chrout
2640 lda ckbyt ;get lgth. to check
2650 sec
2660 sbc #2 ;subtract 2
2670 sta hldr ;temporary save
2680 lda enck ;low byte end add.
2690 sec
2700 sbc hldr ;subtract value
2710 sta enck ;save new value
2720 bcc subhi ;reduce hi byte
2730 set1 lda enck ;get new end add.
2740 sec
2750 sbc ckbyt ;subtract byte lgth
2760 sta mtchck ;save as check value
2770 bcc sub2 ;reduce hi byte
2780 lda enck+1 ;get hi byte new end
2790 set2 sta mtchck+1 ;make same here
2800 set3 lda stadd ;start add. low byte
2810 clc
2820 adc ckbyt ;add byte lgth
2830 sta ckadd ;check pointer
2840 lda stadd+1 ;hi byte
2850 adc #0 ;add carry
2860 sta ckadd+1 ;put in pointer
2870 jmp main ;start main loop
2880 subhi dec enck+1
2890 jmp set1
2900 sub2 lda enck+1
2910 sbc #1
2920 jmp set2
2930 ;*main progam loop*
2940 main ldy #0 ;clear for ind.add.mode
2950 lda (stadd),y ;get value at start
2960 cmp (ckadd),y ;next to check
2970 beq (NULL)tmtch ;they match.check more.
2980 ma1 clc  ;no match
2990 lda ckadd ;add 1 to check add.
3000 adc #1
3010 sta ckadd ;store back
3020 lda ckadd+1 ;fix high byte
3030 adc #0
3040 sta ckadd+1 ;store
3050 lda ckadd ;have we reached
3060 cmp enck ;"end of possible bytes?
3070 bne main ;no.start [130] series
3080 lda ckadd[170]1 ;lo bytes matched
3090 cmp enck[170]1 ;"hi bytes same?
3100 bne main ;no.continue
3110 clc  ;done with this series
3120 lda stadd ;move start pointer
3130 adc #1 ;to next highest byte
3140 sta stadd ;store it
3150 lda stadd+1 ;fix hi byte
3160 adc #0
3170 sta stadd+1
3180 ldx #0 ;clear flag to show print
3190 stx mtchflg ;routine this is new add.
3200 lda stadd ;compare start add.
3210 cmp mtchck ;with last checkable byte
3220 bne return ;no match low byte
3230 lda stadd+1 ;check hi byte
3240 cmp mtchck+1
3250 bne return ;no match
3260 jmp exit ;all done, close up
3270 return jmp set3 ;out of range avoider
3280 ;*check remaining bytes for match*
3290 (NULL)tmtch ldx #0 ;clear indices
3300 ldy #0
3310 lup inx  ;x counts bytes matched
3320 cpx ckbyt ;"checked all?
3330 beq prnt ;yes.[153] 'em
3340 iny  ;no.index [164] [130] byte
3350 lda (stadd),y ;[161] [130] from start
3360 cmp (ckadd),y ;check [129] equality
3370 beq lup ;matches.[161] a[168]her
3380 jmp ma1 ;no match.move up a byte
3390 ;[172]here [139] all bytes match[172]
3400 prnt lda mtchflg ;"printed this stadd?
3410 beq prst ;no, so print it
3420 prnt1 jsr wait ;check for space bar
3430 lda #32 ;indent 2 spaces
3440 jsr chrout
3450 jsr chrout
3460 lda #36 ;$
3470 jsr chrout
3480 ldy #0 ;set upto get 2 bytes
3490 mr2 cpy #2
3500 beq mr1
3510 lda ckadd,y ;get add. of matching bytes
3520 sta hldr,y ;store for conversion
3530 iny  ;get 2nd byte
3540 bne mr2 ;always branch
3550 mr1 jsr prnthx ;convert and print add.
3560 jmp ma1 ;reset ckadd and loop again
3570 ;*print start address matched*
3580 prst lda #$0d ;cr
3590 jsr chrout
3600 lda #36 ;$
3610 jsr chrout
3620 ldy #0 ;set to get 2 bytes
3630 pr2 cpy #2
3640 beq pr1
3650 lda stadd,y ;get 1st byte
3660 sta hldr,y ;save for conversion
3670 iny  ;set for next byte
3680 bne pr2
3690 pr1 jsr prnthx ;convert and print
3700 lda #1 ;set flag to show
3710 sta mtchflg ;stadd was printed
3720 jmp prnt1 ;(NULL) print ckadd
3730 ;*text*
3740 title .byte $20,$20,$20,$12
3750 .asc "common code" :.byte $92,$0d,$0d
3760 .asc "start address in hex ": .byte $0d,$00
3770 ermess .asc "input error":.byte $0d,$00
3780 endmess .asc "end address in hex ":.byte $0d,$00
3790 outmess .asc "output to ": .byte $12
3800 .asc "s": .byte $92
3810 .asc "creen or ":.byte $12
3820 .asc "p": .byte $92
3830 .asc "rinter" :.byte $0d,$00
3840 bytmess .asc "byte length in hex":.byte $0d,$37,$9d,$00
3850 ;*subroutines*
3860 get jsr chrin ;get user input
3870 cmp #$0d ;"cr?
3880 beq d[145]e ;yes.exit routine
3890 sta hxadd,x ;s[164]re [198]ii char.
3900 inx  ;raise idex [129] [130]
3910 bne [161] ;[203] [161] it
3920 d[145]e rts
3930 ;[172]make 1 byte [198]ii in a binary[172]
3940 makbi cmp #58 ;"=>9?
3950 bcs let ;yes, its a letter
3960 sec  ;no so subtract 48
3970 sbc #48 ;for equiv. number
3980 rts  ;return
3990 let sec  ;for a to f
4000 sbc #55 ;subtract 55
4010 rts
4020 ;*check if valid hex ascii*
4030 eval cmp #71 ;"=>g?
4040 bcs bad ;yes, no [203]od
4050 cmp #65 ;"its < g.is it =>a?
4060 bcs (NULL)od ;yes, its valid
4070 cmp #58 ;"its <a.is it =>:?
4080 bcs bad ;yes.no [203]od
4090 cmp #48 ;"<:.is it <0?
4100 bcc bad ;yes. no (NULL)od
4110 (NULL)od clc  ;range ok.
4120 rts  ;back to caller
4130 bad pla  ;invalid.pull return
4140 pla  ;add. from stack
4150 jmp error ;user restart
4160 ;*set up printer file*
4170 prout lda #7 ;file #
4180 ldx #4 ;device
4190 ldy #$ff ;bogus second. add.
4200 jsr setlfs ;define the file
4210 lda #00 ;no name, no length
4220 jsr setnam ;required call
4230 jsr open ;open file 7
4240 ldx #7 ;set file 7 for output
4250 jsr chkout
4260 rts  ;back to caller
4270 ;*check/accept space bar pause*
4280 wait lda #0 ;clear flag to show
4290 sta inflg ;we're not waiting
4300 wa2 lda $cb ;current key pressed
4310 cmp #64 ;64=no key
4320 beq (NULL)on ;no key, nothing to do
4330 cmp #60 ;"space bar?
4340 bne [203][145] ;no, so ign[176]e
4350 lda inflg ;was space bar.
4360 bne g1 ;[139] set,[146] is over
4370 wa1 lda $cb ;start the [146]
4380 cmp #64 ;[129] space bar release
4390 bne wa1 ;keep [146]ing
4400 lda #1 ;set flag [164] show
4410 sta inflg ;we're looking [129] 2nd
4420 jmp wa2 ;hit of space bar
4430 [203][145] lda inflg ;[139] flag set
4440 bne wa2 ;keep looking
4450 g1 rts  ;the [146]s over
4460 ;[172]start curs[176] blink[172]
4470 cr[145] lda #0 ;clear this byte
4480 sta $cc ;[164] start blink
4490 rts
4500 ;[172][144] curs[176] blink[172]
4510 crof lda #1 ;set byte [164]
4520 sta $cc ;[144] blink
4530 rts
4540 ;[172]2 byte binary [164] 4 byte [198]ii hex[172]
4550 makhx ldx #1 ;x set [164] [161] byte
4560 ldy #0 ;y set [164] [148] [198]ii
4570 hx3 lda hldr,x ;[161] byte(hi first)
4580 [175] #$f0 ;mask low nybble
4590 lsr  ;sh[139]t hi nybble [164] low
4600 lsr
4610 lsr
4620 lsr
4630 hx1 cmp #10 ;"=>10?
4640 bcs admor ;yes, make letter
4650 clc  ;no.number
4660 adc #48 ;add 48 for ascii
4670 hx2 sta hxadd,y ;store it
4680 iny  ;raise counter
4690 cpy #3 ;"done 3 nybbles?
4700 beq skip ;yes,do 4th
4710 bcs dun ;y[177]3.we're d[145]e
4720 cpx #0 ;"y<3.hibyte done?
4730 beq nxtbyt ;yes.do low
4740 lda hldr,x ;no.get lo nyb,hi byte
4750 hx4 and #$0f ;mask hi nybble
4760 dex  ;lower counter
4770 jmp hx1 ;make ascii
4780 admor clc  ;convert binary letter
4790 adc #55 ;to ascii by
4800 jmp hx2 ;adding 55
4810 skip lda hldr,x ;get lo byte last time
4820 jmp hx4 ;do lo nybble
4830 nxtbyt ldy #2 ;reset indices fo
4840 ldx #0 ;2nd address byte
4850 jmp hx3 ;loop again
4860 dun rts  ;return
4870 ;*print hex add.stored in hxadd*
4880 prnthx jsr makhx ;binary to hex
4890 ldx #0 ;clear index
4900 lupe cpx #4 ;do 4 numbers
4910 beq fin
4920 lda hxadd,x ;get ascii hex
4930 jsr chrout ;print it
4940 inx  ;point to next char.
4950 bne lupe ;always branch
4960 fin lda #$0d ;cr
4970 jsr chrout
4980 rts  ;return
4990 ;*program finished, clean up*
5000 exit jsr clrchn ;reset default devices
5010 lda #7 ;default value & file#
5020 sta ckbyt ;save it
5030 jsr close ;close file 7
5040 rts  ;back to basic
5050 ;*storage*
5060 hxadd .byte 0,0,0,0 ;4 bytes to hold ascii hex
5070 mtchck .byte 0,0 ;last add. to check
5080 enck .byte 0,0 ;last add. for match
5090 inflg .byte 0 ;user add. input flag
5100 ckbyt .byte $07 ;# bytes to match
5110 mtchflg .byte 0 ;new group flag
5120 hldr .byte 0,0 ;temporary storage
5130 .end